home *** CD-ROM | disk | FTP | other *** search
/ FishMarket 1.0 / FishMarket v1.0.iso / fishies / 551-575 / disk_556 / scheme2c / scheme-src.lzh / scrt / scexpanders2.sc < prev    next >
Text File  |  1991-10-11  |  8KB  |  192 lines
  1. ;;; This module contains the basic macro expanders required by Scheme.
  2.  
  3. ;*              Copyright 1989 Digital Equipment Corporation
  4. ;*                         All Rights Reserved
  5. ;*
  6. ;* Permission to use, copy, and modify this software and its documentation is
  7. ;* hereby granted only under the following terms and conditions.  Both the
  8. ;* above copyright notice and this permission notice must appear in all copies
  9. ;* of the software, derivative works or modified versions, and any portions
  10. ;* thereof, and both notices must appear in supporting documentation.
  11. ;*
  12. ;* Users of this software agree to the terms and conditions set forth herein,
  13. ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
  14. ;* right and license under any changes, enhancements or extensions made to the
  15. ;* core functions of the software, including but not limited to those affording
  16. ;* compatibility with other hardware or software environments, but excluding
  17. ;* applications which incorporate this software.  Users further agree to use
  18. ;* their best efforts to return to Digital any such changes, enhancements or
  19. ;* extensions that they make and inform Digital of noteworthy uses of this
  20. ;* software.  Correspondence should be provided to Digital at:
  21. ;* 
  22. ;*                       Director of Licensing
  23. ;*                       Western Research Laboratory
  24. ;*                       Digital Equipment Corporation
  25. ;*                       100 Hamilton Avenue
  26. ;*                       Palo Alto, California  94301  
  27. ;* 
  28. ;* This software may be distributed (but not offered for sale or transferred
  29. ;* for compensation) to third parties, provided such third parties agree to
  30. ;* abide by the terms and conditions of this notice.  
  31. ;* 
  32. ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
  33. ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  34. ;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
  35. ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
  36. ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
  37. ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
  38. ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  39. ;* SOFTWARE.
  40.  
  41. (module scexpanders2 (top-level))
  42.  
  43. (include "repdef.sc")
  44.  
  45. ;;; (let ((var init)...) body)  ==>  ((lambda (var...) body) init...)
  46. ;;;
  47. ;;; (let var ((v init) ...) body)  ==>  (letrec ((var (lambda (...) body)))
  48. ;;;                        (var init ...))
  49. ;;; LET is expanded into a lambda expression.  While this may make the
  50. ;;; resulting expanded code more difficult to read, later analysis is eased
  51. ;;; because there are fewer forms.  Variable order is retained to make the
  52. ;;; resulting tree easier to compare against the original tree.
  53. ;;;
  54. ;;; A "named let" is expanded into the appropriate letrec expression.  That in
  55. ;;; turn is expanded into the appropriate lambda expression when the letrec
  56. ;;; is expanded.
  57.  
  58. (define (LET-MACRO exp)
  59.     (cond ((and (islist exp 3) (islist (cadr exp) 0))
  60.        (do ((var-inits (cadr exp) (cdr var-inits))
  61.         (vars      '())
  62.         (inits     '()))
  63.            ((or (not (pair? var-inits))
  64.             (not (islist (car var-inits) 2 2))
  65.             (not (symbol? (caar var-inits))))
  66.         (if var-inits
  67.             (error 'let "Illegal form: ~s" exp)
  68.             `((lambda ,(reverse vars) ,@(cddr exp))
  69.               ,@(reverse inits))))
  70.            (set! vars (cons (caar var-inits) vars))
  71.            (set! inits (cons (cadar var-inits) inits))))
  72.       ((and (islist exp 4) (symbol? (cadr exp)))
  73.        (do ((var-inits (caddr exp) (cdr var-inits))
  74.         (vars      '())
  75.         (inits     '()))
  76.            ((or (not (pair? var-inits))
  77.             (not (islist (car var-inits) 2 2))
  78.             (not (symbol? (caar var-inits))))
  79.         (if var-inits
  80.             (error 'let "Illegal form: ~s" exp)
  81.             `(letrec ((,(cadr exp)
  82.                    (lambda ,(reverse vars) ,@(cdddr exp))))
  83.                  (,(cadr exp) ,@(reverse inits)))))
  84.            (set! vars (cons (caar var-inits) vars))
  85.            (set! inits (cons (cadar var-inits) inits))))
  86.       (else (error 'let "Illegal form: ~s" exp))))
  87.  
  88. (install-expander 'LET (lambda (x e) (e (let-macro x) e)))
  89.  
  90. ;;; (let* ((var init)...) body)  ==>  ((lambda (var)
  91. ;;;                           ((lambda (var) body) init))
  92. ;;;                       init)
  93. ;;;
  94. ;;; LET* is expanded into a set of nested lambda expressions.  While this may
  95. ;;; make the resulting code more difficult to read, later analysis is eased
  96. ;;; because there fewer types of forms to analyze.
  97.  
  98. (define (LET*-MACRO exp)
  99.     (cond ((and (islist exp 3) (islist (cadr exp) 1))
  100.        (do ((var-inits (cadr exp) (cdr var-inits))
  101.         (vars      '())
  102.         (inits     '()))
  103.            ((or (not (pair? var-inits))
  104.             (not (islist (car var-inits) 2 2))
  105.             (not (symbol? (caar var-inits))))
  106.         (if var-inits
  107.             (error 'let* "Illegal form: ~s" exp)
  108.             (car (let*-result vars inits (cddr exp)))))
  109.            (set! vars (cons (caar var-inits) vars))
  110.            (set! inits (cons (cadar var-inits) inits))))
  111.       ((and (islist exp 3) (null? (cadr exp)))
  112.        `((lambda () ,@(cddr exp))))
  113.       (else    (error 'let* "Illegal form: ~s" exp))))
  114.  
  115. (install-expander 'LET* (lambda (x e) (e (let*-macro x) e)))
  116.  
  117. (define (LET*-RESULT vars inits body)
  118.     (cond ((null? vars) body)
  119.       (else
  120.        (let*-result (cdr vars) (cdr inits)
  121.            `(((lambda (,(car vars)) ,@body) ,(car inits)))))))
  122.  
  123. ;;; (letrec ((var init)...) body)  ==>  ((lambda (var...)
  124. ;;;                         (set! var init) ...)
  125. ;;;                         body)
  126. ;;;                     undefined ...)
  127. ;;;
  128. ;;; LETREC is expanded into a lambda expression which first binds the vars to
  129. ;;; some undefined value and then evalutes the initialization expressions
  130. ;;; within the lambda expression.  Note that the order of evaluation is
  131. ;;; undefined.
  132.  
  133. (define (LETREC-MACRO exp)
  134.     (cond ((and (islist exp 3) (islist (cadr exp) 1))
  135.        (do ((var-inits (cadr exp) (cdr var-inits))
  136.         (vars      '())
  137.         (sets      '()))
  138.            ((or (not (pair? var-inits))
  139.             (not (islist (car var-inits) 2 2))
  140.             (not (symbol? (caar var-inits))))
  141.         (if var-inits
  142.             (error 'letrec "Illegal form: ~s" exp)
  143.             `((lambda ,(reverse vars)
  144.                   ,@(reverse sets)
  145.                   ,@(cddr exp))
  146.               ,@(map (lambda (v) 0) vars))))
  147.            (set! vars (cons (caar var-inits) vars))
  148.            (set! sets (cons `(set! ,@(car var-inits)) sets))))
  149.       ((and (islist exp 3) (null? (cadr exp)))
  150.        `((lambda () ,@(cddr exp))))
  151.       (else    (error 'letrec "Illegal form: ~s" exp))))
  152.  
  153. (install-expander 'LETREC (lambda (x e) (e (letrec-macro x) e)))
  154.  
  155. ;;; (do ((v1 i1 s1) ...) (test sequence) body ...)  ==>  (letrec ...)
  156. ;;;
  157. ;;; Expands a DO form into the corresponding letrec form.
  158.  
  159. (define  (DO-MACRO exp)
  160.     (cond ((and (islist exp 3) (islist (cadr exp) 0) (islist (caddr exp) 1))
  161.        (let ((let-bindings  (cadr exp))
  162.          (vars         '())
  163.          (inits     '())
  164.          (steps     '())
  165.          (loop        (string->uninterned-symbol "doloop"))
  166.          (test             (caaddr exp))
  167.          (sequence      (or (cdaddr exp) '(#f)))
  168.          (body             (cdddr exp)))
  169.         (for-each
  170.             (lambda (var-init-step)
  171.                 (if (islist var-init-step 2 3)
  172.                 (let* ((var (car var-init-step))
  173.                        (init (cadr var-init-step))
  174.                        (step (if (cddr var-init-step)
  175.                          (caddr var-init-step)
  176.                          var)))
  177.                       (set! vars (cons var vars))
  178.                       (set! steps (cons step steps))
  179.                       (set! inits (cons init inits)))
  180.                 (error 'do "Illegal form:" var-init-step)))
  181.             (reverse let-bindings))
  182.         `(letrec ((,loop (lambda ,vars
  183.                      (if ,test
  184.                          (begin ,@sequence)
  185.                          (begin ,@body
  186.                             (,loop ,@steps))))))
  187.              (,loop ,@inits))))
  188.       (else (error 'do "Illegal form: ~s" 'exp))))
  189.  
  190. (install-expander 'DO (lambda (x e) (e (do-macro x) e)))
  191.  
  192.